home *** CD-ROM | disk | FTP | other *** search
/ NeXT Education Software Sampler 1992 Fall / NeXT Education Software Sampler 1992 Fall.iso / Programming / Source / winterp-1.13 / src-server / xlisp / xlfio.c < prev    next >
Encoding:
C/C++ Source or Header  |  1991-10-04  |  12.0 KB  |  526 lines
  1. /* -*-C-*-
  2. ********************************************************************************
  3. *
  4. * File:         xlfio.c
  5. * RCS:          $Header: xlfio.c,v 1.6 91/03/24 22:24:39 mayer Exp $
  6. * Description:  xlisp file i/o
  7. * Author:       David Michael Betz
  8. * Created:      
  9. * Modified:     Fri Oct  4 03:52:37 1991 (Niels Mayer) mayer@hplnpm
  10. * Language:     C
  11. * Package:      N/A
  12. * Status:       X11r5 contrib tape release
  13. *
  14. * WINTERP Copyright 1989, 1990, 1991 Hewlett-Packard Company (by Niels Mayer).
  15. * XLISP version 2.1, Copyright (c) 1989, by David Betz.
  16. *
  17. * Permission to use, copy, modify, distribute, and sell this software and its
  18. * documentation for any purpose is hereby granted without fee, provided that
  19. * the above copyright notice appear in all copies and that both that
  20. * copyright notice and this permission notice appear in supporting
  21. * documentation, and that the name of Hewlett-Packard and David Betz not be
  22. * used in advertising or publicity pertaining to distribution of the software
  23. * without specific, written prior permission.  Hewlett-Packard and David Betz
  24. * make no representations about the suitability of this software for any
  25. * purpose. It is provided "as is" without express or implied warranty.
  26. *
  27. * HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS
  28. * SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS,
  29. * IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL,
  30. * INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM
  31. * LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE
  32. * OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR
  33. * PERFORMANCE OF THIS SOFTWARE.
  34. *
  35. * See ./winterp/COPYRIGHT for information on contacting the authors.
  36. * 
  37. * Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com
  38. * Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x
  39. *
  40. ********************************************************************************
  41. */
  42. static char rcs_identity[] = "@(#)$Header: xlfio.c,v 1.6 91/03/24 22:24:39 mayer Exp $";
  43.  
  44. #include "xlisp.h"
  45.  
  46. /* external variables */
  47. extern LVAL k_direction,k_input,k_output;
  48. extern LVAL s_stdin,s_stdout,true;
  49. extern unsigned char buf[];
  50. extern int xlfsize;
  51.  
  52. /* external routines */
  53. extern FILE *osaopen();
  54.  
  55. /* forward declarations */
  56. LOCAL FORWARD LVAL getstroutput(); /* NPM: changed this to LOCAL */
  57. LOCAL FORWARD LVAL printit();    /* NPM: changed this to LOCAL */
  58. LOCAL FORWARD LVAL flatsize();    /* NPM: changed this to LOCAL */
  59. /* FORWARD LVAL openit(); */    /* NPM: commented this out since it is not defined anywhere */
  60.  
  61. /* xread - read an expression */
  62. LVAL xread()
  63. {
  64.     LVAL fptr,eof,rflag,val;
  65.  
  66.     /* get file pointer and eof value */
  67.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  68.     eof = (moreargs() ? xlgetarg() : NIL);
  69.     rflag = (moreargs() ? xlgetarg() : NIL);
  70.     xllastarg();
  71.  
  72.     /* read an expression */
  73.     if (!xlread(fptr,&val,rflag != NIL))
  74.     val = eof;
  75.  
  76.     /* return the expression */
  77.     return (val);
  78. }
  79.  
  80. /* xprint - built-in function 'print' */
  81. LVAL xprint()
  82. {
  83.     return (printit(TRUE,TRUE));
  84. }
  85.  
  86. /* xprin1 - built-in function 'prin1' */
  87. LVAL xprin1()
  88. {
  89.     return (printit(TRUE,FALSE));
  90. }
  91.  
  92. /* xprinc - built-in function princ */
  93. LVAL xprinc()
  94. {
  95.     return (printit(FALSE,FALSE));
  96. }
  97.  
  98. /* xterpri - terminate the current print line */
  99. LVAL xterpri()
  100. {
  101.     LVAL fptr;
  102.  
  103.     /* get file pointer */
  104.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  105.     xllastarg();
  106.  
  107.     /* terminate the print line and return nil */
  108.     xlterpri(fptr);
  109.     return (NIL);
  110. }
  111.  
  112. /* printit - common print function */
  113. LOCAL LVAL printit(pflag,tflag)
  114.   int pflag,tflag;
  115. {
  116.     LVAL fptr,val;
  117.  
  118.     /* get expression to print and file pointer */
  119.     val = xlgetarg();
  120.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  121.     xllastarg();
  122.  
  123.     /* print the value */
  124.     xlprint(fptr,val,pflag);
  125.  
  126.     /* terminate the print line if necessary */
  127.     if (tflag)
  128.     xlterpri(fptr);
  129.  
  130.     /* return the result */
  131.     return (val);
  132. }
  133.  
  134. /* xflatsize - compute the size of a printed representation using prin1 */
  135. LVAL xflatsize()
  136. {
  137.     return (flatsize(TRUE));
  138. }
  139.  
  140. /* xflatc - compute the size of a printed representation using princ */
  141. LVAL xflatc()
  142. {
  143.     return (flatsize(FALSE));
  144. }
  145.  
  146. /* flatsize - compute the size of a printed expression */
  147. LOCAL LVAL flatsize(pflag)
  148.   int pflag;
  149. {
  150.     LVAL val;
  151.  
  152.     /* get the expression */
  153.     val = xlgetarg();
  154.     xllastarg();
  155.  
  156.     /* print the value to compute its size */
  157.     xlfsize = 0;
  158.     xlprint(NIL,val,pflag);
  159.  
  160.     /* return the length of the expression */
  161.     return (cvfixnum((FIXTYPE)xlfsize));
  162. }
  163.  
  164. /* xopen - open a file */
  165. LVAL xopen()
  166. {
  167.     char *name,*mode;
  168.     FILE *fp;
  169.     LVAL dir;
  170.  
  171.     /* get the file name and direction */
  172.     name = (char *)getstring(xlgetfname());
  173.     if (!xlgetkeyarg(k_direction,&dir))
  174.     dir = k_input;
  175.  
  176.     /* get the mode */
  177.     if (dir == k_input)
  178.     mode = "r";
  179.     else if (dir == k_output)
  180.     mode = "w";
  181.     else
  182.     xlerror("bad direction",dir);
  183.  
  184.     /* try to open the file */
  185.     return ((fp = osaopen(name,mode)) ? cvfile(fp) : NIL);
  186. }
  187.  
  188. /* xclose - close a file */
  189. LVAL xclose()
  190. {
  191.     LVAL fptr;
  192.  
  193.     /* get file pointer */
  194.     fptr = xlgastream();
  195. #if (defined(UNIX) || defined(WINTERP))
  196.     if (ntype(fptr) == XLTYPE_PIPE)
  197.       xlfail("Pipes must be closed with PCLOSE, not CLOSE.");
  198. #endif /* (defined(UNIX) || defined(WINTERP)) */
  199.     xllastarg();
  200.  
  201.     /* make sure the file exists */
  202.     if (getfile(fptr) == NULL)
  203.     xlfail("file not open");
  204.  
  205.     /* close the file */
  206.     osclose(getfile(fptr));
  207.     setfile(fptr,NULL);
  208.  
  209.     /* return nil */
  210.     return (NIL);
  211. }
  212.  
  213. /* xrdchar - read a character from a file */
  214. LVAL xrdchar()
  215. {
  216.     LVAL fptr;
  217.     int ch;
  218.  
  219.     /* get file pointer */
  220.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  221.     xllastarg();
  222.  
  223.     /* get character and check for eof */
  224.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvchar(ch));
  225. }
  226.  
  227. /* xrdbyte - read a byte from a file */
  228. LVAL xrdbyte()
  229. {
  230.     LVAL fptr;
  231.     int ch;
  232.  
  233.     /* get file pointer */
  234.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  235.     xllastarg();
  236.  
  237.     /* get character and check for eof */
  238.     return ((ch = xlgetc(fptr)) == EOF ? NIL : cvfixnum((FIXTYPE)ch));
  239. }
  240.  
  241. /* xpkchar - peek at a character from a file */
  242. LVAL xpkchar()
  243. {
  244.     LVAL flag,fptr;
  245.     int ch;
  246.  
  247.     /* peek flag and get file pointer */
  248.     flag = (moreargs() ? xlgetarg() : NIL);
  249.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  250.     xllastarg();
  251.  
  252.     /* skip leading white space and get a character */
  253.     if (flag)
  254.     while ((ch = xlpeek(fptr)) != EOF && isspace(ch))
  255.         xlgetc(fptr);
  256.     else
  257.     ch = xlpeek(fptr);
  258.  
  259.     /* return the character */
  260.     return (ch == EOF ? NIL : cvchar(ch));
  261. }
  262.  
  263. /* xwrchar - write a character to a file */
  264. LVAL xwrchar()
  265. {
  266.     LVAL fptr,chr;
  267.  
  268.     /* get the character and file pointer */
  269.     chr = xlgachar();
  270.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  271.     xllastarg();
  272.  
  273.     /* put character to the file */
  274.     xlputc(fptr,getchcode(chr));
  275.  
  276.     /* return the character */
  277.     return (chr);
  278. }
  279.  
  280. /* xwrbyte - write a byte to a file */
  281. LVAL xwrbyte()
  282. {
  283.     LVAL fptr,chr;
  284.  
  285.     /* get the byte and file pointer */
  286.     chr = xlgafixnum();
  287.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  288.     xllastarg();
  289.  
  290.     /* put byte to the file */
  291.     xlputc(fptr,(int)getfixnum(chr));
  292.  
  293.     /* return the character */
  294.     return (chr);
  295. }
  296.  
  297. /* xreadline - read a line from a file */
  298. LVAL xreadline()
  299. {
  300.     unsigned char buf[STRMAX+1],*p,*sptr;
  301.     LVAL fptr,str,newstr;
  302.     int len,blen,ch;
  303.  
  304.     /* protect some pointers */
  305.     xlsave1(str);
  306.  
  307.     /* get file pointer */
  308.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdin));
  309.     xllastarg();
  310.  
  311.     /* get character and check for eof */
  312.     len = blen = 0; p = buf;
  313.     while ((ch = xlgetc(fptr)) != EOF && ch != '\n') {
  314.  
  315.     /* check for buffer overflow */
  316.     if (blen >= STRMAX) {
  317.          newstr = newstring(len + STRMAX + 1);
  318.         sptr = getstring(newstr); *sptr = '\0';
  319.         if (str) strcat(sptr,getstring(str));
  320.         *p = '\0'; strcat(sptr,buf);
  321.         p = buf; blen = 0;
  322.         len += STRMAX;
  323.         str = newstr;
  324.     }
  325.  
  326.     /* store the character */
  327.     *p++ = ch; ++blen;
  328.     }
  329.  
  330.     /* check for end of file */
  331.     if (len == 0 && p == buf && ch == EOF) {
  332.     xlpop();
  333.     return (NIL);
  334.     }
  335.  
  336.     /* append the last substring */
  337.     if (str == NIL || blen) {
  338.     newstr = newstring(len + blen + 1);
  339.     sptr = getstring(newstr); *sptr = '\0';
  340.     if (str) strcat(sptr,getstring(str));
  341.     *p = '\0'; strcat(sptr,buf);
  342.     str = newstr;
  343.     }
  344.  
  345.     /* restore the stack */
  346.     xlpop();
  347.  
  348.     /* return the string */
  349.     return (str);
  350. }
  351.  
  352.  
  353. /* xmkstrinput - make a string input stream */
  354. LVAL xmkstrinput()
  355. {
  356.     int start,end,len,i;
  357.     unsigned char *str;
  358.     LVAL string,val;
  359.  
  360.     /* protect the return value */
  361.     xlsave1(val);
  362.     
  363.     /* get the string and length */
  364.     string = xlgastring();
  365.     str = getstring(string);
  366.     len = getslength(string) - 1;
  367.  
  368.     /* get the starting offset */
  369.     if (moreargs()) {
  370.     val = xlgafixnum();
  371.     start = (int)getfixnum(val);
  372.     }
  373.     else start = 0;
  374.  
  375.     /* get the ending offset */
  376.     if (moreargs()) {
  377.     val = xlgafixnum();
  378.     end = (int)getfixnum(val);
  379.     }
  380.     else end = len;
  381.     xllastarg();
  382.  
  383.     /* check the bounds */
  384.     if (start < 0 || start > len)
  385.     xlerror("string index out of bounds",cvfixnum((FIXTYPE)start));
  386.     if (end < 0 || end > len)
  387.     xlerror("string index out of bounds",cvfixnum((FIXTYPE)end));
  388.  
  389.     /* make the stream */
  390.     val = newustream();
  391.  
  392.     /* copy the substring into the stream */
  393.     for (i = start; i < end; ++i)
  394.     xlputc(val,str[i]);
  395.  
  396.     /* restore the stack */
  397.     xlpop();
  398.  
  399.     /* return the new stream */
  400.     return (val);
  401. }
  402.  
  403. /* xmkstroutput - make a string output stream */
  404. LVAL xmkstroutput()
  405. {
  406.     return (newustream());
  407. }
  408.  
  409. /* xgetstroutput - get output stream string */
  410. LVAL xgetstroutput()
  411. {
  412.     LVAL stream;
  413.     stream = xlgaustream();
  414.     xllastarg();
  415.     return (getstroutput(stream));
  416. }
  417.  
  418. /* xgetlstoutput - get output stream list */
  419. LVAL xgetlstoutput()
  420. {
  421.     LVAL stream,val;
  422.  
  423.     /* get the stream */
  424.     stream = xlgaustream();
  425.     xllastarg();
  426.  
  427.     /* get the output character list */
  428.     val = gethead(stream);
  429.  
  430.     /* empty the character list */
  431.     sethead(stream,NIL);
  432.     settail(stream,NIL);
  433.  
  434.     /* return the list */
  435.     return (val);
  436. }
  437.  
  438. /* xformat - formatted output function */
  439. LVAL xformat()
  440. {
  441.     LVAL fmtstring,stream,val;
  442.     unsigned char *fmt;
  443.     int ch;
  444.  
  445.     /* protect some pointers */
  446.     xlstkcheck(2);
  447.     xlsave(fmtstring);
  448.     xlsave(stream);
  449.  
  450.     /* get the stream and format string */
  451.     stream = xlgetarg();
  452.     if (stream == NIL)
  453.     val = stream = newustream();
  454.     else {
  455.     if (stream == true)
  456.         stream = getvalue(s_stdout);
  457.     else if (!streamp(stream) && !ustreamp(stream))
  458.         xlbadtype(stream);
  459.     val = NIL;
  460.     }
  461.     fmtstring = xlgastring();
  462.     fmt = getstring(fmtstring);
  463.  
  464.     /* process the format string */
  465.     while (ch = *fmt++)
  466.     if (ch == '~') {
  467.         switch (*fmt++) {
  468.         case '\0':
  469.         xlerror("expecting a format directive",cvstring(fmt-1));
  470.         case 'a': case 'A':
  471.         xlprint(stream,xlgetarg(),FALSE);
  472.         break;
  473.         case 's': case 'S':
  474.         xlprint(stream,xlgetarg(),TRUE);
  475.         break;
  476.         case '%':
  477.         xlterpri(stream);
  478.         break;
  479.         case '~':
  480.         xlputc(stream,'~');
  481.         break;
  482.         case '\n':
  483.         while (*fmt && *fmt != '\n' && isspace(*fmt))
  484.             ++fmt;
  485.         break;
  486.         default:
  487.         xlerror("unknown format directive",cvstring(fmt-1));
  488.         }
  489.     }
  490.     else
  491.         xlputc(stream,ch);
  492.     
  493.     /* get the output string for a stream argument of NIL */
  494.     if (val) val = getstroutput(val);
  495.     xlpopn(2);
  496.         
  497.     /* return the value */
  498.     return (val);
  499. }
  500.  
  501. /* getstroutput - get the output stream string (internal) */
  502. LOCAL LVAL getstroutput(stream)
  503.   LVAL stream;
  504. {
  505.     unsigned char *str;
  506.     LVAL next,val;
  507.     int len,ch;
  508.  
  509.     /* compute the length of the stream */
  510.     for (len = 0, next = gethead(stream); next != NIL; next = cdr(next))
  511.     ++len;
  512.  
  513.     /* create a new string */
  514.     val = newstring(len + 1);
  515.     
  516.     /* copy the characters into the new string */
  517.     str = getstring(val);
  518.     while ((ch = xlgetc(stream)) != EOF)
  519.     *str++ = ch;
  520.     *str = '\0';
  521.  
  522.     /* return the string */
  523.     return (val);
  524. }
  525.  
  526.